home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / DECL.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  20KB  |  609 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "vars.h"
  14. #include "gvars.h"
  15. #include "ops.h"
  16. #include "setp.h"
  17. #include "maincasp.h"
  18. #include "miscp.h"
  19. #include "smiscp.h"
  20. #include "segment.h"
  21. #include "genp.h"
  22. #include "typep.h"
  23. #include "statp.h"
  24. #include "segmentp.h"
  25. #include "exprp.h"
  26. #include "gmiscp.h"
  27. #include "gutilp.h"
  28. #include "axqrp.h"
  29. #include "declp.h"
  30.  
  31. static void gen_structured_object(Node, Symbol, int);
  32.  
  33. void create_object(Tuple id_list_arg, Symbol type_name, Node init_node,
  34.   int obj_is_constant)                                         /*;create_object*/
  35. {
  36.     /*
  37.      * This procedure is used to create objects (const or var).
  38.      * id_list is a list (tuple) of name nodes of objects to be created.
  39.      * The initialization part cannot have side effect, unless id_list
  40.      * contains a single element (transformation by expander)
  41.      *
  42.      * In order to generate not too bad a code, this procedure is organized
  43.      * as a gigantic if ... elseif ... elseif... structure, checking for the
  44.      * different configurations. Optimizations may still be added.
  45.      *
  46.      * The following cases are considered:
  47.      *
  48.      *       1/ Size of object and initial value are known statically.
  49.      *             a/ Global object or local constant (promoted to global)
  50.      *                with static initial value.
  51.      *             b/ Global object initialized with dynamic value.
  52.      *                Static part is initialized in data segment.
  53.      *             c/ Uninitialized global object (variable or deferred
  54.      *                constant).
  55.      *             d/ Local constant initialized with dynamic value,
  56.      *                deferred constant, or local variable.
  57.      *              
  58.      *       2/ Size of object is not known statically
  59.      *             a/ Global object with variable size (transformed into
  60.      *                renaming).
  61.      *             b/ Local array or record with variable size.
  62.      *
  63.      */
  64.  
  65.     Node        node, id, first_id, last_id, init_call_node, pre_node;
  66.     Symbol    first_name, obj_name;
  67.     int        obj_is_global, ikind, i, n;
  68.     Fortup    ft1;
  69.     Segment    init_val;    /* type should be Ivalue */
  70.     Node        dyn_node;
  71.     Symbol    model_name, subtype;
  72.     Tuple    tup, id_list;
  73.     Const    ival, small_const;
  74.     int          special_aggregate;
  75.  
  76.     /* id_list_arg needed since id_list used desctructively  6-25-85 */
  77.     id_list = tup_copy(id_list_arg);
  78. #ifdef TRACE
  79.     if (debug_flag) {
  80.         /*gen_trace("CREATE_OBJECT", id_list);*/
  81.         gen_trace("CREATE_OBJECT");
  82.         FORTUP(node = (Node), id_list, ft1);
  83.             gen_trace_node("  CREATE_OBJECT argument", node);
  84.         ENDFORTUP(ft1);
  85.     }
  86. #endif
  87.     init_val = (Segment)0; /* indicate not yet defined */
  88.     obj_is_global = CURRENT_LEVEL == 1;
  89.     if (N_KIND(init_node) == as_init_call) {
  90.         /* Initialization procedure call */
  91.         init_call_node = init_node;
  92.         init_node      = OPT_NODE;
  93.     }
  94.     else {
  95.         init_call_node = OPT_NODE;
  96.     }
  97.  
  98.     while (N_KIND(init_node) == as_insert) {
  99.         FORTUP(pre_node = (Node), N_LIST(init_node), ft1);
  100.             compile(pre_node);
  101.         ENDFORTUP(ft1);
  102.         init_node = N_AST1(init_node);
  103.     }
  104.  
  105.     if (N_KIND(init_node) == as_raise) {
  106.         /* Simplest case, indeed. */
  107.         compile(init_node);
  108.         init_node = OPT_NODE;
  109.     }
  110.  
  111.     if (has_static_size(type_name) && !(is_array_type(type_name)
  112.       &&is_unconstrained(type_name))
  113.       && (init_node == OPT_NODE ||has_static_size(get_type(init_node)))) {
  114.         /*
  115.          * 1- Size of object is known statically(and also size of initial value)
  116.          * -------------------------------------
  117.          */
  118.         if ((obj_is_global || obj_is_constant) && is_ivalue(init_node)) {
  119.             /*
  120.              *         1a- Global object or local const (promoted to global)
  121.              *             with static initial value.
  122.              *             Generate objects in data seg initialized with value
  123.              *             Generate only one object for multiple constants.
  124.              */
  125.             if (is_fixed_type(type_name)) {
  126.                 init_val = segment_new(SEGMENT_KIND_DATA, 1);
  127.                 small_const = small_of(base_type(type_name));
  128.                 segment_put_long(init_val , rat_tof(get_ivalue(init_node),
  129.                   small_const, size_of(type_name) ));
  130.             }
  131.             else if (is_simple_type(type_name)) {
  132.                 ival = get_ivalue(init_node);
  133.                 ikind = ival->const_kind;
  134.                 if(ikind == CONST_INT) {
  135.                     init_val = segment_new(SEGMENT_KIND_DATA, 1);
  136.                     segment_put_word(init_val, ival->const_value.const_int);
  137.                 }
  138.                 else if(ikind == CONST_REAL) {
  139.                     init_val = segment_new(SEGMENT_KIND_DATA, 1);
  140.                     segment_put_real(init_val, ival->const_value.const_real);
  141.                 }
  142.                 else {
  143. #ifdef DEBUG
  144.                     printf("const_kind %d\n", ikind);
  145. #endif        
  146.                     chaos("create_object:unsupported kind");
  147.                 }
  148.             }
  149.             else if (is_array_type(type_name)) {
  150.                 /* build the appropriate vector... */
  151.                 init_val = array_ivalue(init_node);
  152.             }
  153.             else if (is_record_type(type_name)) {
  154.                 init_val = record_ivalue(init_node);
  155.             }
  156.             else {
  157.                 compiler_error_k("Unknown type for constant ", init_node);
  158.                 return;
  159.             }
  160.             if (obj_is_constant) {
  161.                 first_name = get_constant_name(init_val);
  162.                 FORTUP(id = (Node), id_list, ft1);
  163.                     obj_name = N_UNQ(id);
  164.                     assign_same_reference(obj_name, first_name);
  165.                 ENDFORTUP(ft1);
  166.             }
  167.             else {
  168.                 FORTUP(id = (Node), id_list, ft1);
  169.                     obj_name = N_UNQ(id);
  170.                     next_global_reference_segment(obj_name, init_val);
  171.                 ENDFORTUP(ft1);
  172.             }
  173.         }
  174.         else if (obj_is_global && init_node != OPT_NODE) {
  175.             /*
  176.              *          1b- Global object initialized with dynamic value
  177.              *              Generate first object in data seg with static part
  178.              *              initialized, compile code to initialize the rest,
  179.              *              then assign first object to others
  180.              */
  181.             if (N_KIND(init_node) == as_array_aggregate) {
  182.                 init_val = array_ivalue(init_node);
  183.             }
  184.             else if (N_KIND(init_node) == as_record_aggregate) {
  185.                 init_val = record_ivalue(init_node);
  186.             }
  187.             else {
  188.                 /* TBSL: review translation from SETL */
  189.                 /* build segment of desired length, initially all zero */
  190.                 n = size_of(type_name);
  191.                 init_val = segment_new(SEGMENT_KIND_DATA, n);
  192.                 for (i = 1; i <= n; i++) {
  193.                     segment_put_word(init_val, 0);
  194.                 }
  195.             }
  196.             FORTUP(id = (Node), id_list, ft1);
  197.                 obj_name = N_UNQ(id);
  198.                 next_global_reference_segment(obj_name, init_val);
  199.             ENDFORTUP(ft1);
  200.  
  201.             if (is_simple_type(type_name)) {
  202.                 gen_value(init_node);
  203.                 last_id = (Node) tup_frome(id_list);
  204.                 FORTUP(id = (Node), id_list, ft1);
  205.                     id = (Node) tup_fromb(id_list);
  206.                     obj_name = (Symbol) N_UNQ(id);
  207.                     gen_k(I_DUPLICATE, kind_of(type_name));
  208.                     gen_ks(I_POP, kind_of(type_name), obj_name);
  209.                 ENDFORTUP(ft1);
  210.                 obj_name = N_UNQ(last_id);
  211.                 gen_ks(I_POP, kind_of(type_name), obj_name);
  212.             }
  213.             else {
  214.                 first_id = (Node) tup_fromb(id_list);
  215.                 if (is_aggregate(init_node)) {
  216.                     init_node = N_AST2(N_AST1(init_node));
  217.                     compile(init_node);
  218.                 }
  219.                 else {
  220.                     select_assign(first_id, init_node, type_name);
  221.                 }
  222.                 FORTUP(id = (Node), id_list, ft1);
  223.                     select_assign(id, first_id, type_name);
  224.                 ENDFORTUP(ft1);
  225.             }
  226.         }
  227.         else if (obj_is_global) {
  228.             /*
  229.              *         1c- Uninitialized global object (Variable or deferred
  230.              *             constant)
  231.              *             Generate objects in data segment. If initialization
  232.              *             procedure, call it on first object, then assign first
  233.              *             object to others.
  234.              */
  235.             /* build a segment, initially all zeros, of desired length */
  236.             n = size_of(type_name);
  237.             /*
  238.              * this is a kludge for deferred const EMPTY in VAR_STRING package.
  239.              */
  240.             if (n== 0) n = 3;
  241.             init_val = segment_new(SEGMENT_KIND_DATA, n);
  242.             for (i = 1; i <= n; i++)
  243.                 segment_put_word(init_val, 0);
  244.             FORTUP(id = (Node), id_list, ft1);
  245.                 obj_name = N_UNQ(id);
  246.                 next_global_reference_segment(obj_name, init_val);
  247.             ENDFORTUP(ft1);
  248.             if (init_call_node != OPT_NODE ) {
  249.                 compile(init_call_node);     /* This initializes 1st object */
  250.                 first_id = (Node) tup_fromb(id_list);
  251.                 FORTUP(id = (Node), id_list, ft1); /* Assign it to other objs */
  252.                 select_assign(id, first_id, type_name);
  253.                 ENDFORTUP(ft1);
  254.             }
  255.         }
  256.         else {
  257.             /*
  258.              *     1d- Local constant initialized with dynamic val